home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 003 / dbsteel1.arc / TRANSFER.BAS < prev   
BASIC Source File  |  1983-03-10  |  18KB  |  610 lines
  1. 3 DEFDBL X         
  2. 4 DEFINT A-W,Y-Z
  3. 5 DIM F$(15),FLDN$(15,30),FTY(15,30),FL(15,30),IOPT(30)
  4. 10 DIM X$(30),Y$(30)
  5. 13 DIM L(15),NREC(15),Z$(30)
  6. 14 DIM X(30),CK$(30),SN$(30),SFN(10),DTOPT(10) 
  7. 16 DIM LEND(30),CL(30)
  8. 17 DIM FTA(10),ATF(10),BTF(10),IMAX(10)
  9. 18 DIM SU%(40),S!(30),SUM#(40)
  10. 22 DIM ORFLG(10),D(10),TFN(10),FLDTCT(10,30,1),KTSUM(30),SUMFN(30)
  11. 23 DIM SUMF(10,30),KTSUMAF(30),SAFFN(30),SAFADD(10,30),SAFACCTO(10,30)
  12. 24 DIM SAFFLDN(10,30)
  13. 25 DIM S#(30)
  14. 26 DIM MAX(10),Z%(30),SU#(30),D#(30),EFN(10,30)
  15. 35 DIM K$(80)
  16. 42 DIM MAXK(30),SUMRN(10,30),SUMFLDN(10,30),MAXSAF(5)
  17. 44 DIM SUMAFOPT(10),SUMOPT(10),RNTNBOPT(10),DY(10),FLDTC(10,30,1)
  18. 46 DIM SUMFLD(10,30)
  19. 60 DIM SAF#(3,200)
  20. 61 CH = 29: PRINT FRE(0)      
  21. 62 GOSUB 50000
  22. 70 NE = 0
  23. 80 GOSUB 10000
  24. 1000 GOTO 18000
  25. 2300 REM **************  DISK  SELECTION  ***************
  26. 2302 IF HDISK = 2 THEN GOSUB 13000
  27. 2303 IF HDISK = 2 THEN GOTO 2360
  28. 2304 PRINT ""
  29. 2305 PRINT "************  WHICH DISK DRIVE IS THE FILE ON  **************"
  30. 2310 PRINT ""
  31. 2315 PRINT "                 1 - DISK DRIVE A"
  32. 2320 PRINT "                 2 - DISK DRIVE B"
  33. 2325 PRINT "                 3 - DISK DRIVE C"
  34. 2330 PRINT "                 4 - DISK DRIVE D"
  35. 2335 PRINT ""
  36. 2340 PRINT "***********  ENTER THE NUMBER THEN PRESS RETURN  ************"
  37. 2345 GOSUB 14000
  38. 2347 IF DT# < 0 OR DT#>4 GOTO 2345
  39. 2350 T = DT#
  40. 2355 ON T GOTO 2360,2370,2380,2390
  41. 2360 T$ = F$(A)
  42. 2365 GOTO 2490
  43. 2370 T$ = "B:"+F$(A)
  44. 2375 GOTO 2490
  45. 2380 T$ = "C:"+F$(A)
  46. 2385 GOTO 2490
  47. 2390 T$ = "D:"+F$(A)
  48. 2490 RETURN
  49. 2500 REM *******  OPEN FILE SUBROUTINE  *******
  50. 2503 CLOSE #1
  51. 2505 OPEN "R",#1,T$,L(A)
  52. 2507 D = 0
  53. 2510 FOR T = 1 TO NREC(A)
  54. 2520 FIELD #1,D AS DY$,FL(A,T) AS X$(T)
  55. 2530 D = D + FL(A,T)
  56. 2540 NEXT T
  57. 2543 GOSUB 7800
  58. 2545 RETURN
  59. 2550 REM *******   OPEN SECOND FILE  *******
  60. 2553 CLOSE #2
  61. 2555 OPEN "R",#2,T$,L(B)
  62. 2557 D = 0
  63. 2560 FOR T = 1 TO NREC(B)
  64. 2565 FIELD #2,D AS DY$,FL(B,T) AS Y$(T)
  65. 2570 D = D + FL(B,T)
  66. 2575 NEXT T
  67. 2578 RETURN
  68. 2580 REM *******   OPEN THIRD FILE  *******
  69. 2582 PRINT C,F$(C),L(C)
  70. 2584 OPEN "R",#2,F$(C),L(C)
  71. 2586 D = 0
  72. 2588 FOR T = 1 TO NREC(C)
  73. 2590 FIELD #2,D AS DY$,FL(C,T) AS Z$(T)
  74. 2592 D = D + FL(C,T)
  75. 2594 NEXT T
  76. 2596 RETURN
  77. 7800 MRN = LOF(1)/ L(A)
  78. 7805 REM MRN = INT(MRN)
  79. 7810 RETURN
  80. 7900 REM ***** LOF
  81. 7910 MRN2 = LOF(3)/82
  82. 7920 RETURN
  83. 7950 REM ******* LOF
  84. 7960 MRNS = LOF(B)/L(B)
  85. 7970 RETURN
  86. 10000 REM *************  READ SUBROUTINE  *************
  87. 10004 GOSUB 10900
  88. 10010 OPEN "I",#1,"FFILE"
  89. 10020 INPUT #1,MAXF
  90. 10030 FOR A = 1 TO MAXF
  91. 10040 INPUT #1,A,F$(A),NREC(A),L(A)
  92. 10050 FOR N = 1 TO NREC(A)
  93. 10060 INPUT #1,FLDN$(A,N),FTY(A,N),FL(A,N)
  94. 10070 IF FTY(A,N) = 2 THEN INPUT #1,D,D
  95. 10080 NEXT N
  96. 10090 NEXT A
  97. 10100 CLOSE #1
  98. 10110 RETURN
  99. 10900 REM  *************  PUT DISK IN DRIVE SUB
  100. 10905 IF HDISK = 2 THEN RETURN
  101. 10910 GOSUB 13000
  102. 10920 PRINT "    ********  PUT PROGRAM DATA DISK IN THE DEFAULT DISK DRIVE  *********"
  103. 10930 PRINT ""
  104. 10940 PRINT "                     THEN PRESS ANY KEY TO CONTINUE "
  105. 10950 PRINT ""
  106. 10960 PRINT "    If the program data disk is already in the default disk drive then"
  107. 10965 PRINT "                   just press any key to continue."
  108. 10970 PRINT ""
  109. 10990 IF INKEY$ = "" GOTO 10990
  110. 10995 RETURN
  111. 11000 REM  ********  LOAD KEYLIST  *********
  112. 11010 RETURN
  113. 13000 REM *********  CLEAR SCREEN
  114. 13010 CLS
  115. 13020 RETURN
  116. 13100 REM *********  LOCATE  
  117. 13110 LOCATE LI,1
  118. 13120 RETURN
  119. 13200 FOR T% = 1 TO 80
  120. 13210 PRINT CHR$(8);
  121. 13220 NEXT T%
  122. 13222 FOR T% = 1 TO 24
  123. 13223 PRINT CHR$(11);
  124. 13224 NEXT T%
  125. 13225 LI = LI - 1
  126. 13230 FOR T% = 1 TO LI
  127. 13240 PRINT CHR$(0)
  128. 13250 NEXT T%
  129. 13590 RETURN
  130. 13600 REM ****** CHECK FOR ASC0
  131. 13610 S4$ = INKEY$
  132. 13620 C2 =  ASC(S4$)
  133. 13630 IF C2 = 83 THEN C = 1
  134. 13640 IF C2 = 82 THEN C = 6
  135. 13650 IF C2 = 75 THEN C = 19
  136. 13660 IF C2 = 77 THEN C = 4 
  137. 13670 RETURN
  138. 14000 REM *******  INTEGER LESS THEN 100 CHECK  ********
  139. 14010 MAX = 2
  140. 14020 ACT$ = "1234567890=<>^"
  141. 14023 IF NE = 0 THEN ACT$ = "1234567890"
  142. 14025 PRINT ">__<";
  143. 14030 GOTO 14500
  144. 14100 REM *******  INTEGER *******                        
  145. 14110 MAX = 8
  146. 14120 ACT$ = "1234567890-+,=<>^"
  147. 14123 IF NE = 0 THEN ACT$ = "1234567890-+,"
  148. 14125 PRINT ">________<";
  149. 14130 GOTO 14500
  150. 14200 REM *******  SINGLE PRECISION  *******                        
  151. 14210 MAX = 10
  152. 14220 ACT$ = "1234567890-+,.%$=<>^"
  153. 14223 IF NE = 0 THEN ACT$ = "1234567890+-,.%$"
  154. 14225 PRINT ">__________<";
  155. 14230 GOTO 14500
  156. 14300 REM *******  DOUBLE PRECISION  *******                        
  157. 14310 MAX = 20
  158. 14320 ACT$ = "1234567890-+,.%$=<>^"
  159. 14323 IF NE = 0 THEN ACT$ = "1234567890+-,.%$"
  160. 14325 PRINT ">____________________<";
  161. 14330 GOTO 14500
  162. 14500 REM ********** NUMBER CHECK **********
  163. 14505 A$ = ""
  164. 14510 K$(20) = " "
  165. 14515 KTMAX = 0
  166. 14520 FOR T9 = 1 TO MAX
  167. 14525 K$(T9) = " "
  168. 14530 NEXT T9
  169. 14535 DIG$ = "1234567890."
  170. 14540 DOTFLG = 0
  171. 14541 T2 = MAX + 1
  172. 14542 FOR T6 = 1 TO T2
  173. 14544 PRINT CHR$(CH);
  174. 14546 NEXT T6
  175. 14550 IF INKEY$ = "" GOTO 14560 ELSE GOTO 14550
  176. 14560 KT = 0
  177. 14565 REM ***********  CHECK ALFANUMERIC INPUT FOR LENGTH  ***********
  178. 14570 KT = KT + 1
  179. 14575 REM     
  180. 14580 W$ = INKEY$
  181. 14585 IF W$ = "" GOTO 14580
  182. 14590 C = ASC(W$)
  183. 14593 IF C = 0 THEN GOSUB 13600
  184. 14595 IF C = 13 GOTO 14660
  185. 14600 IF C = 17 OR C = 8 GOTO 14860
  186. 14605 IF C = 19 GOTO 14690
  187. 14610 IF C = 4 GOTO 14710
  188. 14615 IF C = 6 GOTO 14730
  189. 14620 IF C = 1 GOTO 14790
  190. 14625 IF KT > MAX GOTO 14575
  191. 14630 IF INSTR(ACT$,W$) = 0 GOTO 14890
  192. 14635 K$(KT) = W$
  193. 14645 PRINT K$(KT);
  194. 14650 IF KT > KTMAX THEN KTMAX = KT
  195. 14655 GOTO 14570
  196. 14660 REM **********  RETURN  **********
  197. 14670 FOR T9 = 1 TO KTMAX
  198. 14675 A$ = A$ + K$(T9)
  199. 14680 NEXT T9
  200. 14681 IF KTMAX = 0 THEN PRINT "1"
  201. 14682 IF KTMAX = 0 THEN DT# = 1
  202. 14683 IF KTMAX = 0 THEN RETURN
  203. 14684 PRINT ""
  204. 14685 GOTO 14905
  205. 14690 REM ********* MOVE CURSE BACK ********
  206. 14695 IF KT = 1 GOTO 14575
  207. 14700 KT = KT - 1
  208. 14703 PRINT CHR$(CH);
  209. 14705 GOTO 14575
  210. 14710 REM ********* MOVE CURSER FORWARD *********
  211. 14715 IF KT >= MAX GOTO 14575
  212. 14716 IF KT > (KTMAX + 1) GOTO 14575
  213. 14718 PRINT K$(KT);
  214. 14720 KT = KT + 1
  215. 14725 GOTO 14575
  216. 14730 REM ********** INSERT ***********
  217. 14733 IF KT > KTMAX GOTO 14575
  218. 14735 X9 = MAX
  219. 14740 WHILE X9 > KT
  220. 14745 X9 = X9 - 1
  221. 14750 K$(X9 + 1) = K$(X9)
  222. 14755 WEND 
  223. 14760 K$(KT) = " "
  224. 14767 KTMAX = KTMAX + 1
  225. 14769 IF KTMAX > MAX THEN KTMAX = MAX
  226. 14770 FOR T9 = KT TO KTMAX
  227. 14775 PRINT K$(T9);
  228. 14780 NEXT T9
  229. 14781 T6 = (KTMAX - KT) + 1
  230. 14782 FOR T7 = 1 TO T6
  231. 14783 PRINT CHR$(CH);
  232. 14784 NEXT T7
  233. 14785 GOTO 14575
  234. 14790 REM ********** DELETE ***********
  235. 14793 IF KT > KTMAX GOTO 14575
  236. 14794 IF KTMAX = 1 GOTO 14575
  237. 14795 K$(MAX + 1) = ""
  238. 14800 X9 = KT 
  239. 14805 WHILE X9 <= MAX
  240. 14810 K$(X9) = K$(X9 + 1)
  241. 14815 X9 = X9 + 1
  242. 14820 WEND 
  243. 14830 KTMAX = KTMAX - 1
  244. 14835 FOR T9 = KT TO KTMAX
  245. 14840 PRINT K$(T9);
  246. 14845 NEXT T9
  247. 14850 PRINT "_";
  248. 14851 T7 = (KTMAX - KT) + 2
  249. 14852 FOR T8 = 1 TO T7
  250. 14853 PRINT CHR$(CH);
  251. 14854 NEXT T8
  252. 14855 GOTO 14575
  253. 14860 REM ********* BACKSPACE ********
  254. 14865 IF KT = 1 GOTO 14575
  255. 14870 KT = KT - 1
  256. 14875 PRINT CHR$(CH);
  257. 14877 K$(KT) = " " 
  258. 14880 PRINT "_";
  259. 14883 PRINT CHR$(CH);
  260. 14885 GOTO 14575
  261. 14890 REM *******  INPUT NOT ACCEPTABLE  ********
  262. 14895 PRINT CHR$(7);
  263. 14900 GOTO 14580
  264. 14905 REM ********* CLEAR STRINGS ********
  265. 14910 MAX = LEN(A$)
  266. 14915 D2$ = ""
  267. 14920 D1$ = ""
  268. 14925 DFLG = 0
  269. 14930 FOR Q93 = 1 TO MAX
  270. 14935 R$ = MID$(A$,Q93,1)
  271. 14940 IF INSTR(DIG$,R$) = 0 GOTO 14975
  272. 14945 IF R$ = "." OR DFLG = 1 GOTO 14965
  273. 14950 IF DFLG = 1 GOTO 14965
  274. 14955 D2$ = D2$ + R$
  275. 14960 GOTO 14975
  276. 14965 D1$ = D1$ + R$
  277. 14970 DFLG = 1
  278. 14975 NEXT Q93
  279. 14980 DA# = VAL(D2$)
  280. 14985 D1# = VAL(D1$)
  281. 14990 DT# = DA# + D1#
  282. 14995 IF K$(1) = "-" THEN DT# =  -DT#   
  283. 14997 RETURN
  284. 16010 PRINT "***********  MAKE SURE YOUR PRINTER IS ON  **************"
  285. 16020 PRINT ""
  286. 16030 PRINT "********************  WITH PAPER  ***********************"
  287. 16040 PRINT ""
  288. 16050 PRINT "**********  PRESS ANY KEY TO START PRINTING  ************"
  289. 16055 PRINT ""
  290. 16057 PRINT "     *******  PRESS THE LETTER A TO ABORT  *******"
  291. 16070 T$ = INKEY$
  292. 16073 IF T$ = "" GOTO 16070
  293. 16075 PRINT T$
  294. 16090 RETURN
  295. 16200 REM *********  PRINT OUT FIELDS
  296. 16205 T2 = 1
  297. 16210 FOR T = 1 TO NREC(A)
  298. 16220 PRINT TAB(T2) T;"-";FLDN$(A,T);
  299. 16230 IF T MOD 3 = 0 THEN PRINT ""
  300. 16235 IF T MOD 3 = 0 THEN T2 = -25
  301. 16237 T2 = T2 + 26
  302. 16340 NEXT T
  303. 16350 RETURN
  304. 18000 REM **********  TRANSFER  MENU  **************
  305. 18005 IF DTFLG >< 1 THEN GOSUB 19000
  306. 18007 GOSUB 13000
  307. 18010 PRINT "****************  TRANSFER MENU  ******************"
  308. 18020 PRINT ""
  309. 18025 PRINT "   0 - EXIT THE PROGRAM"
  310. 18030 FOR N = 1 TO MAXS
  311. 18040 PRINT "  ";N;"- ";SN$(N)
  312. 18050 NEXT N
  313. 18060 PRINT ""
  314. 18070 PRINT "*******  ENTER THE NUMBER AND PRESS RETURN  *******"
  315. 18075 GOSUB 14000
  316. 18076 IF DT# <0 OR DT# >MAXS GOTO 18075
  317. 18078 IF DT# = 0 THEN GOTO 51000
  318. 18080 SOPT = DT#
  319. 18085 GOSUB 13000
  320. 18090 A = SFN(SOPT)
  321. 18092 PRINT F$(A),"SOURCE FILE"
  322. 18094 GOSUB 2300
  323. 18096 GOSUB 2500
  324. 18098 IF DTOPT(SOPT) = 1 THEN GOSUB 21000
  325. 18099 GOSUB 13000
  326. 18100 PRINT ""
  327. 18110 PRINT "*****  WHAT RECORD NUMBER DO YOU WANT TO START AT  *****"
  328. 18120 PRINT ""
  329. 18130 PRINT "*********  ENTER THE NUMBER THEN PRESS RETURN  *********"
  330. 18135 GOSUB 14200
  331. 18136 IF DT# <1 OR DT# >10000  GOTO 18135
  332. 18140 RNSS = DT#
  333. 18200 PRINT ""
  334. 18202 GOSUB 7800
  335. 18204 PRINT "THE HIGHEST NUMBERED RECORD IS ";MRN
  336. 18210 PRINT "********  WHICH IS THE LAST RECORD YOU WANT TO TRANSFER  ********"
  337. 18220 PRINT ""
  338. 18230 PRINT "*************  ENTER THE NUMBER THEN PRESS RETURN  **************"
  339. 18235 GOSUB 14200
  340. 18236 IF DT# <1 OR DT# >MRN GOTO 18235
  341. 18240 RNSF = DT#
  342. 18250 IF RNSF > MRN GOTO 18204
  343. 18300 SFN = SFN(SOPT)
  344. 18500 GOTO 20000
  345. 19000 REM ************  OPEN FOR INPUT  **************
  346. 19005 GOSUB 10900
  347. 19010 OPEN "I",#2,"TFER"
  348. 19020 INPUT #2,MAXS
  349. 19030 FOR S = 1 TO MAXS 
  350. 19040 D = 1
  351. 19050 INPUT #2,DTOPT(S),SUMOPT(S),SUMAFOPT(S),SN$(S),SFN(S)
  352. 19060 IF DTOPT(S) = 2 GOTO 19170
  353. 19070 INPUT #2,RNTNBOPT(S),D(S),TFN(S),DY(S)
  354. 19080 TFN = TFN(S)
  355. 19090 FOR N = 1 TO DY(S)    
  356. 19100 INPUT #2,FLDTC(S,N,D)
  357. 19110 IF FLDTC(S,N,D) = 1 GOTO 19130
  358. 19120 INPUT #2,FLDTCT(S,N,D)
  359. 19130 NEXT N
  360. 19140 IF D = 2 GOTO 19170
  361. 19150 IF D(S) = 2 THEN D = 2
  362. 19160 IF D(S) = 2 GOTO 19090
  363. 19170 IF SUMOPT(S) = 2 GOTO 19220
  364. 19180 INPUT #2,KTSUM(S),SUMFN(S)
  365. 19190 FOR K = 1 TO KTSUM(S)
  366. 19200 INPUT #2,SUMF(S,K),SUMRN(S,K),SUMFLDN(S,K)
  367. 19210 NEXT K
  368. 19220 IF SUMAFOPT(S) = 2 GOTO 19270
  369. 19230 INPUT #2, KTSUMAF(S),SAFFN(S)
  370. 19240 FOR K = 1 TO KTSUMAF(S)
  371. 19250 INPUT #2,SAFADD(S,K),SAFACCTO(S,K),SAFFLDN(S,K),DY
  372. 19260 NEXT K
  373. 19270 NEXT S
  374. 19280 CLOSE #2
  375. 19285 DTFLG = 1
  376. 19290 RETURN
  377. 20000 REM ******  DATA TRANSFER PROGRAM  ******
  378. 20095 REM *****  INITIALIZE SUMS TO ZERO *****
  379. 20100 GOSUB 20900
  380. 20105 PRINT "*** INITIALIXE SUMS
  381. 20110 REM *** OPEN SOURCE FILE ****
  382. 20112 GOSUB 13000
  383. 20140 REM ** IF DTOPT(SOPT) = 1 THEN GOSUB 21000
  384. 20150 REM *******  START READING LOOP  **********
  385. 20160 FOR RN = RNSS TO RNSF
  386. 20180 GET #1,RN
  387. 20195 REM *******  CONVERT STRINGS TO INTEGERS 
  388. 20200 GOSUB 21066
  389. 20205 PRINT "***  READING RECORD NUMBER ";RN 
  390. 20210 REM *******  RECORD NUMBERING
  391. 20220 IF DTOPT(SOPT) = 1 THEN GOSUB 21700
  392. 20230 REM *****  TRANSFER DATA
  393. 20240 IF DTOPT(SOPT) = 1 THEN GOSUB 21900
  394. 20250 REM *****  ADD ACCORDING TO FIELDS 
  395. 20260 IF SUMOPT(SOPT) = 1 THEN GOSUB 24000
  396. 20270 IF SUMAFOPT(SOPT) = 1 THEN GOSUB 24100
  397. 20300 NEXT RN
  398. 20500 REM  ******  RESUME FROM ON ERROR
  399. 20510 REM ******  MOVE FIELDS TO FILE
  400. 20520 IF SUMOPT(SOPT) = 1 THEN GOSUB 25600
  401. 20530 IF SUMAFOPT(SOPT) = 1 THEN GOSUB 25800
  402. 20590 CLOSE
  403. 20600 GOTO 18000
  404. 20900 REM ******  CLEAR VARIABLES  ******
  405. 20910 FOR N = 1 TO KTSUM
  406. 20920 SUM#(N) = 0
  407. 20930 NEXT N
  408. 20950 IF SUMAFOPT = 2 GOTO 20998
  409. 20960 FOR P = 1 TO KTSUMAF
  410. 20970 FOR N = 1 TO MAX(P)
  411. 20980 SAF#(P,N) = 0
  412. 20990 NEXT N
  413. 20995 NEXT P
  414. 20998 RETURN
  415. 21000 REM ***********  DATA TRANSFER OPTION  **********
  416. 21005 TFN = TFN(SOPT)
  417. 21010 B = TFN
  418. 21015 GOSUB 13000
  419. 21017 PRINT F$(B)," TARGET FILE "
  420. 21018 AHLD = A
  421. 21019 A = B
  422. 21020 GOSUB 2300
  423. 21030 GOSUB 2550
  424. 21032 A = AHLD
  425. 21040 RETURN
  426. 21066 FOR K = 1 TO NREC(A)
  427. 21068 REM ******** CONVERT EACH RECORD TO DECIMAL  **********
  428. 21070 ON FTY(A,K) GOTO 21100,21200,21300,21400,21400
  429. 21100 Z$(K) = X$(K)
  430. 21110 GOTO 21500
  431. 21150 REM *******  START READING LOOP  **********
  432. 21200 Z%(K) = CVI(X$(K))
  433. 21205 SU#(K) = Z%(K)
  434. 21210 GOTO 21500
  435. 21300 S!(K) = CVS(X$(K))
  436. 21305 SU#(K) = S!(K)
  437. 21310 GOTO 21500
  438. 21400 D#(K) = CVD(X$(K))
  439. 21405 SU#(K) = D#(K)
  440. 21410 GOTO 21500
  441. 21500 NEXT K
  442. 21510 RETURN                 
  443. 21590 REM ******* GET SECOND FILE **********
  444. 21595 REM ***** OPEN B ON START UP  ****
  445. 21600 IF N <> RNSS GOTO 21700
  446. 21605 FLG = 1
  447. 21610 FLDOPT = 2
  448. 21620 B = TFN
  449. 21630 GOSUB 2300 
  450. 21700 REM *****  RECORD NUMBERING
  451. 21705 RNTNBOPT = RNTNBOPT(SOPT)
  452. 21710 IF RNTNBOPT = 0 GOTO 21800
  453. 21715 REM ******  B RECORD NUMBER = TO A FIELD ******
  454. 21720 RN2 = SU#(RNTNBOPT)
  455. 21730 RETURN    
  456. 21790 REM ****** B RECORD NUMBER INCREMENTS FROM 1 *******
  457. 21800 RN2 = RN 
  458. 21810 RETURN   
  459. 21900 REM ****** GET SECOND RECORD  ******
  460. 21905 PRINT "TRANSFERING TO RECORD ";RN2 
  461. 21910 GET #2,RN2
  462. 22000 FOR R = 1 TO NREC(B)
  463. 22005 REM *****  NO TRASFER  *****
  464. 22010 IF FLDTC(SOPT,R,1) = 1 GOTO 23900
  465. 22020 IF FTY(B,R) <> 1 GOTO 22100
  466. 22030 T = FLDTC(SOPT,R,1) - 1
  467. 22040 LSET Y$(R) = Z$(T)
  468. 22050 GOTO 23900
  469. 22095 REM *****  JUST REPLACE  *****
  470. 22100 IF FLDTCT(SOPT,R,1) <> 2 GOTO 22200
  471. 22105 T = FLDTC(SOPT,R,1) - 1
  472. 22110 LSET Y$(R) = Z$(T)
  473. 22120 GOTO 23900
  474. 22200 ON FTY(B,R) GOTO 23900,22210,22300,22400,22400
  475. 22205 REM ***** INTEGER *****
  476. 22210 I%=CVI(Y$(R))
  477. 22215 T = FLDTC(SOPT,R,1) - 1
  478. 22218 D# = SU#(T)
  479. 22220 IF FLDTCT(SOPT,R,1) = 3 THEN D# = -1 * D#   
  480. 22230 I% = I% + D#   
  481. 22240 LSET Y$(R) = MKI$(I%)
  482. 22250 GOTO 23900
  483. 22300 REM ** SINGLE PRECISION **
  484. 22310 I!=CVS(Y$(R))
  485. 22315 T = FLDTC(SOPT,R,1) - 1
  486. 22318 D# = SU#(T)
  487. 22320 IF FLDTCT(SOPT,R,1) = 3 THEN D# = -1 * D#   
  488. 22330 I! = I! + D#   
  489. 22340 LSET Y$(R) = MKS$(I!)
  490. 22350 GOTO 23900
  491. 22400 REM ** DOUBLE PRECISION **
  492. 22407 Y$ = Y$(R)
  493. 22410 I#=CVD(Y$)   
  494. 22415 T = FLDTC(SOPT,R,1) - 1
  495. 22416 D# = SU#(T)
  496. 22420 IF FLDTCT(SOPT,R,1) = 3 THEN D# = -1 * D#   
  497. 22430 I# = I# + D#   
  498. 22440 LSET Y$(R) = MKD$(I#)
  499. 22450 GOTO 23900
  500. 22990 REM ****** FINISH TRANSFER LOOP ******
  501. 23900 NEXT R
  502. 23910 PUT #2,RN2
  503. 23912 RETURN
  504. 24000 REM ******** SUM OPTION *******
  505. 24010 FOR P = 1 TO KTSUM(SOPT)
  506. 24020 T = SUMF(SOPT,P)
  507. 24030 SUM#(P) = SUM#(P) + SU#(T)
  508. 24040 NEXT P
  509. 24050 RETURN
  510. 24100 REM ***** ADD ACCORDING TO FIELDS *****
  511. 24110 IF SUMAFOPT = 2 GOTO 24285
  512. 24120 FOR P = 1 TO KTSUMAF(SOPT)
  513. 24130 T = SAFADD(SOPT,P) 
  514. 24140 F = SAFACCTO(SOPT,P)
  515. 24150 I = SU#(F)    
  516. 24155 IF I > MAXSAF(P) THEN MAXSAF(P) = I
  517. 24160 SAF#(P,I) = SAF#(P,I) + SU#(T)
  518. 24170 NEXT P
  519. 24285 RETURN 
  520. 25600 REM ****** MOVE SUMS TO FILES ******
  521. 25620 CLOSE
  522. 25630 B = SUMFN(SOPT)
  523. 25645 GOSUB 13000
  524. 25647 PRINT F$(B),"FILE FOR SUMS"
  525. 25648 AHLD = A
  526. 25649 A = B
  527. 25650 GOSUB 2300
  528. 25660 GOSUB 2550 
  529. 25665 A = AHLD
  530. 25670 FOR P = 1 TO KTSUM(SOPT)
  531. 25700 RN = SUMRN(SOPT,P)
  532. 25710 GET 2,RN
  533. 25720 T = SUMFLDN(SOPT,P)
  534. 25725 S# = SUM#(P)
  535. 25727 PRINT "SUM";S#;" FIELD ";T
  536. 25730 ON FTY(B,T) GOSUB  25790,25772,25780,25790,25790
  537. 25750 PUT #2,RN
  538. 25760 NEXT P
  539. 25770 RETURN
  540. 25772 LSET Y$(T) = MKI$(S#)
  541. 25775 RETURN
  542. 25780 LSET Y$(T) = MKS$(S#)
  543. 25785 RETURN
  544. 25790 LSET Y$(T) = MKD$(S#)
  545. 25795 RETURN
  546. 25800 REM *******  PUT SUM ACCORDING TO FIELDS IN FILES  *******
  547. 25810 CLOSE
  548. 25820 B = SAFFN(SOPT)
  549. 25823 GOSUB 13000
  550. 25825 PRINT F$(B),"FILE FOR SUMS ACCORDINT TO FIELDS "
  551. 25827 AHLD = A
  552. 25828 A = B
  553. 25830 GOSUB 2300
  554. 25833 A = AHLD
  555. 25835 GOSUB 2550
  556. 25850 FOR P = 1 TO KTSUMAF(SOPT)
  557. 25852 T = SAFFLDN(SOPT,P)
  558. 25860 FOR J = 1 TO MAXSAF(P)
  559. 25865 S# = SAF#(P,J)
  560. 25870 GET #2,J
  561. 25880 ON FTY(B,T) GOSUB 25984,25984,25990,25995,25995
  562. 25890 PUT #2,J
  563. 25895 PRINT P,J,S#,A,T
  564. 25900 NEXT J
  565. 25910 NEXT P
  566. 25980 CLOSE
  567. 25982 RETURN       
  568. 25984 LSET Y$(T) = MKI$(S#)
  569. 25986 RETURN
  570. 25990 LSET Y$(T) = MKS$(S#)
  571. 25992 RETURN
  572. 25995 LSET Y$(T) = MKD$(S#)
  573. 25997 RETURN
  574. 26000 REM ******* ON ERROR ROUTINE ************
  575. 26100 EFLG = 1
  576. 26200 PRINT "**********  END OF FILE  ***********"
  577. 26202 PRINT "**** PRESS ANY KEY TO CONTINUE ****"
  578. 26204 IF INKEY$ = "" GOTO 26204
  579. 26500 REM *********  ON ERROR SUBROUTINE ***********
  580. 26600 PRINT "**********  END OF FILE  ***********"
  581. 26610 PRINT "**** PRESS ANY KEY TO CONTINUE ****"
  582. 26620 IF INKEY$ = "" GOTO 26620
  583. 26635 EFLG = 1
  584. 26640 RETURN        
  585. 26800 REM **********  ON ERROR GOTO  **************
  586. 26900 PRINT "************  RECORD NOT FOUND  *************"
  587. 50000 REM **********  INTRO
  588. 50010 GOSUB 13000
  589. 50100 PRINT "              T R A N S F E R    P R O G R A M    3.0   "
  590. 50105 PRINT ""
  591. 50110 PRINT "       Copyright 1984 by Potomac Pacific Engineering Inc."
  592. 50120 PRINT ""
  593. 50130 PRINT "This program is licensed FREE to all users with some restrictions"
  594. 50165 PRINT "        See the manual for more information on the license."
  595. 50167 PRINT ""
  596. 50950 PRINT "******************  PRESS ANY KEY TO CONTINUE  *******************";
  597. 50960 IF INKEY$ = "" GOTO 50960
  598. 50970 RETURN
  599. 51000 REM ******** EXIT
  600. 51100 GOSUB 13000
  601. 51105 GOSUB 13000
  602. 51110 PRINT " -BYE, Have a nice day
  603. 51120 END
  604. 51200 PRINT "BYE - Have a nice day "
  605. 51300 END
  606. SUB 13000
  607. 51105 GOSUB 13000
  608. 51110 PRINT " -BYE, Have a nice day
  609. 51120 END
  610. 51